home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _7526407f3ea251df1ddbe9b2c55f67c0 < prev    next >
Encoding:
Text File  |  2002-05-01  |  12.4 KB  |  514 lines
  1. package Net::HTTP::Methods;
  2.  
  3. # $Id: Methods.pm,v 1.7 2001/12/05 16:58:05 gisle Exp $
  4.  
  5. require 5.005;  # 4-arg substr
  6.  
  7. use strict;
  8. use vars qw($VERSION);
  9.  
  10. $VERSION = "0.02";
  11.  
  12. my $CRLF = "\015\012";   # "\r\n" is not portable
  13.  
  14. sub new {
  15.     my($class, %cnf) = @_;
  16.     require Symbol;
  17.     my $self = bless Symbol::gensym(), $class;
  18.     return $self->http_configure(\%cnf);
  19. }
  20.  
  21. sub http_configure {
  22.     my($self, $cnf) = @_;
  23.  
  24.     die "Listen option not allowed" if $cnf->{Listen};
  25.     my $host = delete $cnf->{Host};
  26.     my $peer = $cnf->{PeerAddr} || $cnf->{PeerHost};
  27.     if ($host) {
  28.     $cnf->{PeerAddr} = $host unless $peer;
  29.     }
  30.     else {
  31.     $host = $peer;
  32.     $host =~ s/:.*//;
  33.     }
  34.     $cnf->{PeerPort} = $self->http_default_port unless $cnf->{PeerPort};
  35.     $cnf->{Proto} = 'tcp';
  36.  
  37.     my $keep_alive = delete $cnf->{KeepAlive};
  38.     my $http_version = delete $cnf->{HTTPVersion};
  39.     $http_version = "1.1" unless defined $http_version;
  40.     my $peer_http_version = delete $cnf->{PeerHTTPVersion};
  41.     $peer_http_version = "1.0" unless defined $peer_http_version;
  42.     my $send_te = delete $cnf->{SendTE};
  43.     my $max_line_length = delete $cnf->{MaxLineLength};
  44.     $max_line_length = 4*1024 unless defined $max_line_length;
  45.     my $max_header_lines = delete $cnf->{MaxHeaderLines};
  46.     $max_header_lines = 128 unless defined $max_header_lines;
  47.  
  48.     return undef unless $self->http_connect($cnf);
  49.  
  50.     unless ($host =~ /:/) {
  51.     my $p = $self->peerport;
  52.     $host .= ":$p";
  53.     }
  54.     $self->host($host);
  55.     $self->keep_alive($keep_alive);
  56.     $self->send_te($send_te);
  57.     $self->http_version($http_version);
  58.     $self->peer_http_version($peer_http_version);
  59.     $self->max_line_length($max_line_length);
  60.     $self->max_header_lines($max_header_lines);
  61.  
  62.     ${*$self}{'http_buf'} = "";
  63.  
  64.     return $self;
  65. }
  66.  
  67. sub http_default_port {
  68.     80;
  69. }
  70.  
  71. # set up property accessors
  72. for my $method (qw(host keep_alive send_te max_line_length max_header_lines peer_http_version)) {
  73.     my $prop_name = "http_" . $method;
  74.     no strict 'refs';
  75.     *$method = sub {
  76.     my $self = shift;
  77.     my $old = ${*$self}{$prop_name};
  78.     ${*$self}{$prop_name} = shift if @_;
  79.     return $old;
  80.     };
  81. }
  82.  
  83. # we want this one to be a bit smarter
  84. sub http_version {
  85.     my $self = shift;
  86.     my $old = ${*$self}{'http_version'};
  87.     if (@_) {
  88.     my $v = shift;
  89.     $v = "1.0" if $v eq "1";  # float
  90.     unless ($v eq "1.0" or $v eq "1.1") {
  91.         require Carp;
  92.         Carp::croak("Unsupported HTTP version '$v'");
  93.     }
  94.     ${*$self}{'http_version'} = $v;
  95.     }
  96.     $old;
  97. }
  98.  
  99. sub format_request {
  100.     my $self = shift;
  101.     my $method = shift;
  102.     my $uri = shift;
  103.  
  104.     my $content = (@_ % 2) ? pop : "";
  105.  
  106.     for ($method, $uri) {
  107.     require Carp;
  108.     Carp::croak("Bad method or uri") if /\s/ || !length;
  109.     }
  110.  
  111.     push(@{${*$self}{'http_request_method'}}, $method);
  112.     my $ver = ${*$self}{'http_version'};
  113.     my $peer_ver = ${*$self}{'http_peer_http_version'} || "1.0";
  114.  
  115.     my @h;
  116.     my @connection;
  117.     my %given = (host => 0, "content-length" => 0, "te" => 0);
  118.     while (@_) {
  119.     my($k, $v) = splice(@_, 0, 2);
  120.     my $lc_k = lc($k);
  121.     if ($lc_k eq "connection") {
  122.         push(@connection, split(/\s*,\s*/, $v));
  123.         next;
  124.     }
  125.     if (exists $given{$lc_k}) {
  126.         $given{$lc_k}++;
  127.     }
  128.     push(@h, "$k: $v");
  129.     }
  130.  
  131.     if (length($content) && !$given{'content-length'}) {
  132.     push(@h, "Content-Length: " . length($content));
  133.     }
  134.  
  135.     my @h2;
  136.     if ($given{te}) {
  137.     push(@connection, "TE") unless grep lc($_) eq "te", @connection;
  138.     }
  139.     elsif ($self->send_te && zlib_ok()) {
  140.     # gzip is less wanted since the Compress::Zlib interface for
  141.     # it does not really allow chunked decoding to take place easily.
  142.     push(@h2, "TE: deflate,gzip;q=0.3");
  143.     push(@connection, "TE");
  144.     }
  145.  
  146.     unless (grep lc($_) eq "close", @connection) {
  147.     if ($self->keep_alive) {
  148.         if ($peer_ver eq "1.0") {
  149.         # from looking at Netscape's headers
  150.         push(@h2, "Keep-Alive: 300");
  151.         unshift(@connection, "Keep-Alive");
  152.         }
  153.     }
  154.     else {
  155.         push(@connection, "close") if $ver ge "1.1";
  156.     }
  157.     }
  158.     push(@h2, "Connection: " . join(", ", @connection)) if @connection;
  159.     push(@h2, "Host: ${*$self}{'http_host'}") unless $given{host};
  160.  
  161.     return join($CRLF, "$method $uri HTTP/$ver", @h2, @h, "", $content);
  162. }
  163.  
  164.  
  165. sub write_request {
  166.     my $self = shift;
  167.     $self->print($self->format_request(@_));
  168. }
  169.  
  170. sub format_chunk {
  171.     my $self = shift;
  172.     return $_[0] unless defined($_[0]) && length($_[0]);
  173.     return hex(length($_[0])) . $CRLF . $_[0] . $CRLF;
  174. }
  175.  
  176. sub write_chunk {
  177.     my $self = shift;
  178.     return 1 unless defined($_[0]) && length($_[0]);
  179.     $self->print(hex(length($_[0])) . $CRLF . $_[0] . $CRLF);
  180. }
  181.  
  182. sub format_chunk_eof {
  183.     my $self = shift;
  184.     my @h;
  185.     while (@_) {
  186.     push(@h, sprintf "%s: %s$CRLF", splice(@_, 0, 2));
  187.     }
  188.     return join("", "0$CRLF", @h, $CRLF);
  189. }
  190.  
  191. sub write_chunk_eof {
  192.     my $self = shift;
  193.     $self->print($self->format_chunk_eof(@_));
  194. }
  195.  
  196.  
  197. sub my_read {
  198.     die if @_ > 3;
  199.     my $self = shift;
  200.     my $len = $_[1];
  201.     for (${*$self}{'http_buf'}) {
  202.     if (length) {
  203.         $_[0] = substr($_, 0, $len, "");
  204.         return length($_[0]);
  205.     }
  206.     else {
  207.         return $self->sysread($_[0], $len);
  208.     }
  209.     }
  210. }
  211.  
  212.  
  213. sub my_readline {
  214.     my $self = shift;
  215.     for (${*$self}{'http_buf'}) {
  216.     my $max_line_length = ${*$self}{'http_max_line_length'};
  217.     my $pos;
  218.     while (1) {
  219.         # find line ending
  220.         $pos = index($_, "\012");
  221.         last if $pos >= 0;
  222.         die "Line too long (limit is $max_line_length)"
  223.         if $max_line_length && length($_) > $max_line_length;
  224.  
  225.         # need to read more data to find a line ending
  226.         my $n = $self->sysread($_, 1024, length);
  227.         if (!$n) {
  228.         return undef unless length;
  229.         return substr($_, 0, length, "");
  230.         }
  231.     }
  232.     die "Line too long ($pos; limit is $max_line_length)"
  233.         if $max_line_length && $pos > $max_line_length;
  234.  
  235.     my $line = substr($_, 0, $pos+1, "");
  236.     $line =~ s/(\015?\012)\z// || die "Assert";
  237.     return wantarray ? ($line, $1) : $line;
  238.     }
  239. }
  240.  
  241.  
  242. sub _rbuf {
  243.     my $self = shift;
  244.     if (@_) {
  245.     for (${*$self}{'http_buf'}) {
  246.         my $old;
  247.         $old = $_ if defined wantarray;
  248.         $_ = shift;
  249.         return $old;
  250.     }
  251.     }
  252.     else {
  253.     return ${*$self}{'http_buf'};
  254.     }
  255. }
  256.  
  257. sub _rbuf_length {
  258.     my $self = shift;
  259.     return length ${*$self}{'http_buf'};
  260. }
  261.  
  262.  
  263. sub _read_header_lines {
  264.     my $self = shift;
  265.     my $junk_out = shift;
  266.  
  267.     my @headers;
  268.     my $line_count = 0;
  269.     my $max_header_lines = ${*$self}{'http_max_header_lines'};
  270.     while (my $line = my_readline($self)) {
  271.     if ($line =~ /^(\S+)\s*:\s*(.*)/s) {
  272.         push(@headers, $1, $2);
  273.     }
  274.     elsif (@headers && $line =~ s/^\s+//) {
  275.         $headers[-1] .= " " . $line;
  276.     }
  277.     elsif ($junk_out) {
  278.         push(@$junk_out, $line);
  279.     }
  280.     else {
  281.         die "Bad header: '$line'\n";
  282.     }
  283.     if ($max_header_lines) {
  284.         $line_count++;
  285.         if ($line_count >= $max_header_lines) {
  286.         die "Too many header lines (limit is $max_header_lines)";
  287.         }
  288.     }
  289.     }
  290.     return @headers;
  291. }
  292.  
  293.  
  294. sub read_response_headers {
  295.     my($self, %opt) = @_;
  296.     my $laxed = $opt{laxed};
  297.  
  298.     my($status, $eol) = my_readline($self);
  299.     die "EOF instead of reponse status line" unless defined $status;
  300.  
  301.     my($peer_ver, $code, $message) = split(/\s+/, $status, 3);
  302.     if (!$peer_ver || $peer_ver !~ s,^HTTP/,,) {
  303.     die "Bad response status line: '$status'" unless $laxed;
  304.     # assume HTTP/0.9
  305.     ${*$self}{'http_peer_http_version'} = "0.9";
  306.     ${*$self}{'http_status'} = "200";
  307.     substr(${*$self}{'http_buf'}, 0, 0) = $status . $eol;
  308.     return (200, "Assumed OK");
  309.     };
  310.  
  311.     ${*$self}{'http_peer_http_version'} = $peer_ver;
  312.  
  313.     unless ($code =~ /^[1-9]\d\d$/) {
  314.     die "Bad response code: '$status'";
  315.     }
  316.     ${*$self}{'http_status'} = $code;
  317.  
  318.     my $junk_out;
  319.     if ($laxed) {
  320.     $junk_out = $opt{junk_out} || [];
  321.     }
  322.     my @headers = $self->_read_header_lines($junk_out);
  323.  
  324.     # pick out headers that read_entity_body might need
  325.     my @te;
  326.     my $content_length;
  327.     for (my $i = 0; $i < @headers; $i += 2) {
  328.     my $h = lc($headers[$i]);
  329.     if ($h eq 'transfer-encoding') {
  330.         push(@te, $headers[$i+1]);
  331.     }
  332.     elsif ($h eq 'content-length') {
  333.         $content_length = $headers[$i+1];
  334.     }
  335.     }
  336.     ${*$self}{'http_te'} = join(",", @te);
  337.     ${*$self}{'http_content_length'} = $content_length;
  338.     ${*$self}{'http_first_body'}++;
  339.     delete ${*$self}{'http_trailers'};
  340.     return $code unless wantarray;
  341.     return ($code, $message, @headers);
  342. }
  343.  
  344.  
  345. sub read_entity_body {
  346.     my $self = shift;
  347.     my $buf_ref = \$_[0];
  348.     my $size = $_[1];
  349.     die "Offset not supported yet" if $_[2];
  350.  
  351.     my $chunked;
  352.     my $bytes;
  353.  
  354.     if (${*$self}{'http_first_body'}) {
  355.     ${*$self}{'http_first_body'} = 0;
  356.     delete ${*$self}{'http_chunked'};
  357.     delete ${*$self}{'http_bytes'};
  358.     my $method = shift(@{${*$self}{'http_request_method'}});
  359.     my $status = ${*$self}{'http_status'};
  360.     if ($method eq "HEAD" || $status =~ /^(?:1|[23]04)/) {
  361.         # these responses are always empty
  362.         $bytes = 0;
  363.     }
  364.     elsif (my $te = ${*$self}{'http_te'}) {
  365.         my @te = split(/\s*,\s*/, lc($te));
  366.         die "Chunked must be last Transfer-Encoding '$te'"
  367.         unless pop(@te) eq "chunked";
  368.  
  369.         for (@te) {
  370.         if ($_ eq "deflate" && zlib_ok()) {
  371.             #require Compress::Zlib;
  372.             my $i = Compress::Zlib::inflateInit();
  373.             die "Can't make inflator" unless $i;
  374.             $_ = sub { scalar($i->inflate($_[0])) }
  375.         }
  376.         elsif ($_ eq "gzip" && zlib_ok()) {
  377.             #require Compress::Zlib;
  378.             my @buf;
  379.             $_ = sub {
  380.             push(@buf, $_[0]);
  381.             return Compress::Zlib::memGunzip(join("", @buf)) if $_[1];
  382.             return "";
  383.             };
  384.         }
  385.         elsif ($_ eq "identity") {
  386.             $_ = sub { $_[0] };
  387.         }
  388.         else {
  389.             die "Can't handle transfer encoding '$te'";
  390.         }
  391.         }
  392.  
  393.         @te = reverse(@te);
  394.  
  395.         ${*$self}{'http_te2'} = @te ? \@te : "";
  396.         $chunked = -1;
  397.     }
  398.     elsif (defined(my $content_length = ${*$self}{'http_content_length'})) {
  399.         $bytes = $content_length;
  400.     }
  401.     else {
  402.         # XXX Multi-Part types are self delimiting, but RFC 2616 says we
  403.         # only has to deal with 'multipart/byteranges'
  404.  
  405.         # Read until EOF
  406.     }
  407.     }
  408.     else {
  409.     $chunked = ${*$self}{'http_chunked'};
  410.     $bytes   = ${*$self}{'http_bytes'};
  411.     }
  412.  
  413.     if (defined $chunked) {
  414.     # The state encoded in $chunked is:
  415.     #   $chunked == 0:   read CRLF after chunk, then chunk header
  416.         #   $chunked == -1:  read chunk header
  417.     #   $chunked > 0:    bytes left in current chunk to read
  418.  
  419.     if ($chunked <= 0) {
  420.         my $line = my_readline($self);
  421.         if ($chunked == 0) {
  422.         die "Not empty: '$line'" unless $line eq "";
  423.         $line = my_readline($self);
  424.         }
  425.         $line =~ s/;.*//;  # ignore potential chunk parameters
  426.         $line =~ s/\s+$//; # avoid warnings from hex()
  427.         $chunked = hex($line);
  428.         if ($chunked == 0) {
  429.         ${*$self}{'http_trailers'} = [$self->_read_header_lines];
  430.         $$buf_ref = "";
  431.  
  432.         my $n = 0;
  433.         if (my $transforms = delete ${*$self}{'http_te2'}) {
  434.             for (@$transforms) {
  435.             $$buf_ref = &$_($$buf_ref, 1);
  436.             }
  437.             $n = length($$buf_ref);
  438.         }
  439.  
  440.         # in case somebody tries to read more, make sure we continue
  441.         # to return EOF
  442.         delete ${*$self}{'http_chunked'};
  443.         ${*$self}{'http_bytes'} = 0;
  444.  
  445.         return $n;
  446.         }
  447.     }
  448.  
  449.     my $n = $chunked;
  450.     $n = $size if $size && $size < $n;
  451.     $n = my_read($self, $$buf_ref, $n);
  452.     return undef unless defined $n;
  453.  
  454.     ${*$self}{'http_chunked'} = $chunked - $n;
  455.  
  456.     if ($n > 0) {
  457.         if (my $transforms = ${*$self}{'http_te2'}) {
  458.         for (@$transforms) {
  459.             $$buf_ref = &$_($$buf_ref, 0);
  460.         }
  461.         $n = length($$buf_ref);
  462.         $n = -1 if $n == 0;
  463.         }
  464.     }
  465.     return $n;
  466.     }
  467.     elsif (defined $bytes) {
  468.     unless ($bytes) {
  469.         $$buf_ref = "";
  470.         return 0;
  471.     }
  472.     my $n = $bytes;
  473.     $n = $size if $size && $size < $n;
  474.     $n = my_read($self, $$buf_ref, $n);
  475.     return undef unless defined $n;
  476.     ${*$self}{'http_bytes'} = $bytes - $n;
  477.     return $n;
  478.     }
  479.     else {
  480.     # read until eof
  481.     $size ||= 8*1024;
  482.     return my_read($self, $$buf_ref, $size);
  483.     }
  484. }
  485.  
  486. sub get_trailers {
  487.     my $self = shift;
  488.     @{${*$self}{'http_trailers'} || []};
  489. }
  490.  
  491. BEGIN {
  492. my $zlib_ok;
  493.  
  494. sub zlib_ok {
  495.     return $zlib_ok if defined $zlib_ok;
  496.  
  497.     # Try to load Compress::Zlib.
  498.     local $@;
  499.     local $SIG{__DIE__};
  500.     $zlib_ok = 0;
  501.  
  502.     eval {
  503.     require Compress::Zlib;
  504.     Compress::Zlib->VERSION(1.10);
  505.     $zlib_ok++;
  506.     };
  507.  
  508.     return $zlib_ok;
  509. }
  510.  
  511. } # BEGIN
  512.  
  513. 1;
  514.